home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / AsciiCoder.Mod (.txt) next >
Encoding:
Oberon Text  |  1995-06-23  |  10.7 KB  |  214 lines  |  [TEXT/.Ob4]
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax10b.Scn.Fnt
  4. MODULE AsciiCoder; (* Wolfgang Weck 10 Sep 93, compression due to Stefan Ludwig *)
  5.     IMPORT Texts, Files, Oberon, Viewers, MenuViewers, TextFrames, Display;
  6.     CONST
  7.         Base = 48; StopBase = 35;
  8.         N = 16384;
  9.         Menu = "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Replace  Edit.Parcs  Edit.Store EditTools.StoreAscii ";
  10.     TYPE
  11.         NameList = POINTER TO NameDesc;
  12.         NameDesc = RECORD
  13.             next: NameList;
  14.             name: POINTER TO ARRAY 64 OF CHAR
  15.         END;
  16.         w: Texts.Writer;
  17.         table: ARRAY N OF CHAR;    (* hash table for compression *)
  18.     PROCEDURE Compress*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  19.         VAR
  20.             from, to: Files.Rider;
  21.             hash, byte, bit, i: LONGINT;
  22.             ch: CHAR;
  23.     BEGIN
  24.         i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  25.         Files.Set(from, src, 0); Files.Set(to, dest, 0);
  26.         i := Files.Length(src); Files.WriteNum(to, i);
  27.         hash := 0; bit := 0; byte := 0;
  28.         REPEAT
  29.             Files.Read(from, ch);
  30.             IF table[hash] = ch THEN    (* 0 bit for correct prediction *)
  31.                 INC(bit); IF bit = 8 THEN Files.Write(to, CHR(byte)); byte := 0; bit := 0 END
  32.             ELSE    (* Incorrect prediction -> 1'xxxx'xxxx bits where x = ch[0..7] *)
  33.                 table[hash] := ch; INC(byte, ASH(1, bit)); INC(bit);
  34.                 IF bit = 8 THEN Files.Write(to, CHR(byte)); Files.Write(to, ch);  byte := 0; bit := 0
  35.                 ELSE Files.Write(to, CHR(byte+ASH(ORD(ch), bit) MOD 256)); byte := ASH(ORD(ch), bit) DIV 256
  36.                 END
  37.             END;
  38.             DEC(i); hash := (16*hash+ORD(ch)) MOD N    (* hash value *)
  39.         UNTIL i = 0;
  40.         IF bit # 0 THEN Files.Write(to, CHR(byte)) END    (* write last byte *)
  41.     END Compress;
  42.     PROCEDURE Expand*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  43.         VAR
  44.             from, to: Files.Rider;
  45.             hash, val, byte, bit, i: LONGINT;
  46.             ch: CHAR;
  47.     BEGIN
  48.         i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  49.         Files.Set(from, src, 0); Files.Set(to, dest, 0);
  50.         Files.ReadNum(from, i); Files.Read(from, ch); val := ORD(ch); bit := 0; hash := 0;
  51.         REPEAT
  52.             INC(bit);
  53.             IF ODD(val) THEN    (* Incorrect prediction -> 1'xxxx'xxxx *)
  54.                 Files.Read(from, ch);
  55.                 IF bit = 8 THEN byte := ORD(ch)
  56.                 ELSE byte := val DIV 2 + ASH(ORD(ch), 8-bit) MOD 256; val := ASH(ORD(ch), -bit)
  57.                 END;
  58.                 table[hash] := CHR(byte)
  59.             ELSE byte := ORD(table[hash]); val := val DIV 2    (* correct prediction *)
  60.             END;
  61.             hash := (16*hash+byte) MOD N; Files.Write(to, CHR(byte)); DEC(i);
  62.             IF bit = 8 THEN Files.Read(from, ch); val := ORD(ch); bit := 0 END
  63.         UNTIL i = 0
  64.     END Expand;
  65.     PROCEDURE Code*(from: Files.File; to: Texts.Text);
  66.         VAR r: Files.Rider; ch: CHAR; byte, rest, div, factor, packs: INTEGER;
  67.     BEGIN Files.Set(r, from, 0); Files.Read(r, ch); byte := ORD(ch); rest := 0; div := 64; factor  := 1; packs := 0;
  68.         WHILE ~r.eof DO Texts.Write(w, CHR(Base + rest + (byte MOD div) * factor)); rest := byte DIV div;
  69.             IF div = 4 THEN Texts.Write(w, CHR(Base + rest));
  70.                 rest := 0; div := 64; factor  := 1; INC(packs);
  71.                 IF packs = 19 THEN Texts.WriteLn(w); packs := 0 END
  72.             ELSE factor := factor * 4; div := div DIV 4
  73.             END;
  74.             Files.Read(r, ch); byte := ORD(ch)
  75.         END;
  76.         IF div = 64 THEN Texts.Write(w, CHR(StopBase))
  77.         ELSIF div = 16 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 1))
  78.         ELSIF div = 4 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 2))
  79.         END;
  80.         Texts.WriteLn(w); Texts.Append(to, w.buf)
  81.     END Code;
  82.     PROCEDURE Decode*(from: Texts.Text; VAR pos: LONGINT; to: Files.File; VAR ok: BOOLEAN);
  83.         VAR r: Texts.Reader; w: Files.Rider; rest, div, factor, byte: INTEGER; ch: CHAR;
  84.     BEGIN Texts.OpenReader(r, from, pos); Files.Set(w, to, 0); factor := 1; div := 256;
  85.         REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot;
  86.         WHILE ~r.eot & (ch >= CHR(Base)) & (ch < CHR(Base + 64)) DO byte := ORD(ch) - Base;
  87.             IF factor # 1 THEN Files.Write(w, CHR(rest + (byte MOD div) * factor));
  88.                 rest := byte DIV div; div := div * 4; factor := factor DIV 4
  89.             ELSE rest := byte; div := 4; factor := 64
  90.             END;
  91.             REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot
  92.         END;
  93.         byte := ORD(ch) - StopBase;
  94.         ok := (byte = 0) & (div = 256) OR (byte = 1) & (div = 16) OR (byte = 2) & (div = 64) & (rest = 0);
  95.         pos := Texts.Pos(r)
  96.     END Decode;
  97.     PROCEDURE OpenViewer(name: ARRAY OF CHAR; text: Texts.Text);
  98.         VAR v: Viewers.Viewer; f: Display.Frame; x, y: INTEGER;
  99.     BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, x, y);
  100.         f := TextFrames.NewText(text, 0);
  101.         v := MenuViewers.New(TextFrames.NewMenu(name, Menu), f, TextFrames.menuH, x, y)
  102.     END OpenViewer;
  103.     PROCEDURE ReadFileNames(t: Texts.Text; beg, end: LONGINT; VAR names: NameList; VAR pos: LONGINT);
  104.         VAR last, n: NameList; s: Texts.Scanner;
  105.     BEGIN NEW(names); last := names; Texts.OpenScanner(s, t, beg); pos := beg; Texts.Scan(s);
  106.         WHILE (pos < end) & ((s.class = Texts.String) OR (s.class = Texts.Name)) DO NEW(n); last.next := n; last := n;
  107.             NEW(n.name); COPY(s.s, n.name^);
  108.             pos := Texts.Pos(s); Texts.Scan(s)
  109.         END;
  110.         last.next := NIL; names := names.next; pos := Texts.Pos(s)
  111.     END ReadFileNames;
  112.     PROCEDURE CodeFiles*;
  113.         VAR pos, beg, end, time: LONGINT; compress: BOOLEAN; names, n: NameList;
  114.             f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; 
  115.     BEGIN pos := Oberon.Par.pos; compress := FALSE;
  116.         Texts.OpenScanner(s, Oberon.Par.text, pos); Texts.Scan(s);
  117.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  118.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "^") THEN Oberon.GetSelection(text, beg, end, time);
  119.             IF time >= 0 THEN ReadFileNames(text, beg, end, names, time) ELSE names := NIL END
  120.         ELSE ReadFileNames(Oberon.Par.text, pos, Oberon.Par.text.len, names, time)
  121.         END;
  122.         IF names # NIL THEN n := names; text := TextFrames.Text("");
  123.             Texts.WriteString(w, "AsciiCoder.CodeFiles"); Texts.WriteLn(w);
  124.             REPEAT f := Files.Old(n.name^); Texts.WriteString(w, n.name^);
  125.                 IF f = NIL THEN Texts.WriteString(w, " not found"); n.name := NIL
  126.                 ELSE Texts.WriteString(w, " coding"); Texts.Append(Oberon.Log, w.buf);
  127.                     IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  128.                     Code(f, text)
  129.                 END;
  130.                 Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); n := n.next
  131.             UNTIL n = NIL;
  132.             Texts.WriteString(w,"AsciiCoder.DecodeFiles ");
  133.             IF compress THEN Texts.WriteString(w, "% ") END;
  134.             REPEAT
  135.                 IF names.name # NIL THEN Texts.WriteString(w, names.name^); Texts.Write(w, " ") END;
  136.                 names := names.next
  137.             UNTIL names = NIL;
  138.             Texts.Write(w, "~"); Texts.WriteLn(w); Texts.WriteLn(w); Texts.Insert(text, 0, w.buf);
  139.             Texts.WriteInt(w, text.len, 0); Texts.WriteString(w, " characters"); Texts.WriteLn(w);
  140.             Texts.Append(Oberon.Log, w.buf);
  141.             OpenViewer("AsciiCoder.CodeFiles", text)
  142.         END
  143.     END CodeFiles;
  144.     PROCEDURE DecodeFiles*;
  145.         VAR pos, beg, end, time: LONGINT; i, res: INTEGER; ch: CHAR; ok, compress: BOOLEAN;
  146.             f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; names: NameList; bakname: ARRAY 256 OF CHAR;
  147.     BEGIN text := Oberon.Par.text; pos := Oberon.Par.pos; compress := FALSE;
  148.         Texts.OpenScanner(s, text, pos); Texts.Scan(s);
  149.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  150.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  151.             IF time >= 0 THEN ReadFileNames(text, beg, end, names, pos) ELSE names := NIL END
  152.         ELSE ReadFileNames(text, pos, text.len, names, pos)
  153.         END;
  154.         Texts.WriteString(w, "AsciiCoder.DecodeFiles"); Texts.WriteLn(w); ok := TRUE;
  155.         WHILE (names # NIL) & ok DO f := Files.New(names.name^);
  156.             Texts.WriteString(w, names.name^); Texts.WriteString(w, " decoding"); Texts.Append(Oberon.Log, w.buf);
  157.             i := 0; ch := names.name[0];
  158.             WHILE ch # 0X DO bakname[i] := ch; INC(i); ch := names.name[i] END;
  159.             bakname[i] := "."; bakname[i + 1] := "B"; bakname[i + 2] := "a"; bakname[i + 3] := "k"; bakname[i + 4] := 0X;
  160.             Files.Rename(names.name^, bakname, res); Decode(text, pos, f, ok);
  161.             IF ok THEN
  162.                 IF compress THEN f1 := Files.New(names.name^); Expand(f, f1); f := f1 END;
  163.                 Files.Register(f)
  164.             ELSE Texts.WriteString(w, " error.")
  165.             END;
  166.             Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); names := names.next
  167.         END
  168.     END DecodeFiles;
  169.     PROCEDURE CodeText*;
  170.         VAR beg, end, time: LONGINT; compress: BOOLEAN;
  171.             v: Viewers.Viewer; f, f1: Files.File; r: Files.Rider; t, text: Texts.Text; s: Texts.Scanner;
  172.     BEGIN compress := FALSE;
  173.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  174.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; Texts.Scan(s) END;
  175.         IF (s.line = 0) & (s.class = Texts.Char) THEN t := NIL;
  176.             IF s.c = "*" THEN v := Oberon.MarkedViewer();
  177.                 IF (v IS MenuViewers.Viewer) & (v.dsc.next IS TextFrames.Frame) THEN
  178.                     t := v.dsc.next(TextFrames.Frame).text
  179.                 END
  180.             ELSIF s.c = "@" THEN Oberon.GetSelection(text, beg, end, time);
  181.                 IF time >= 0 THEN t := TextFrames.Text(""); Texts.Save(text, beg, end, w.buf); Texts.Append(t, w.buf) END
  182.             END;
  183.             IF t # NIL THEN f := Files.New(""); Files.Set(r, f, 0); Files.Write(r, 0F0X); Files.Write(r, 01X); Texts.Store(r, t);
  184.                 text := TextFrames.Text("");
  185.                 Texts.WriteString(w, "AsciiCoder.DecodeText");
  186.                 IF compress THEN Texts.WriteString(w, " %") END;
  187.                 Texts.WriteLn(w); Texts.WriteLn(w); Texts.Append(text, w.buf);
  188.                 IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  189.                 Code(f, text); OpenViewer("AsciiCoder.CodeText", text);
  190.                 Texts.WriteString(w, "AsciiCoder.CodeText "); Texts.WriteInt(w, text.len, 0);
  191.                 Texts.WriteString(w, " characters"); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  192.             END
  193.         END
  194.     END CodeText;
  195.     PROCEDURE DecodeText*;
  196.         VAR pos, beg, end, time: LONGINT; ok, compress: BOOLEAN;
  197.             f, f1: Files.File; r: Files.Rider; text: Texts.Text; s: Texts.Scanner;
  198.     BEGIN compress := FALSE; pos := Oberon.Par.pos; f := Files.New("");
  199.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  200.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  201.         IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  202.             IF time >= 0 THEN Decode(text, beg, f, ok) ELSE ok := FALSE END
  203.         ELSE Decode(Oberon.Par.text, pos, f, ok)
  204.         END;
  205.         IF ok THEN
  206.             IF compress THEN f1 := Files.New(""); Expand(f, f1); f := f1 END;
  207.             text := TextFrames.Text(""); Files.Set(r, f, 2); Texts.Load(r, text);
  208.             OpenViewer("AsciiCoder.DecodeText", text)
  209.         ELSE Texts.WriteString(w, "AsciiCoder.DecodeText error."); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  210.         END
  211.     END DecodeText;
  212. BEGIN Texts.OpenWriter(w)
  213. END AsciiCoder.
  214.